home *** CD-ROM | disk | FTP | other *** search
/ Nibble Magazine / nib16.dsk / GRAPHICS 3D.bas < prev    next >
BASIC Source File  |  2023-02-26  |  5KB  |  146 lines
  1. 10  REM  ************************
  2. 20  REM  *     GRAPHICS  3D     *
  3. 30  REM  * BY RICHARD GOLDSTEIN *
  4. 40  REM  *  COPYRIGHT (C) 1983  *
  5. 50  REM  * BY  MICROSPARC, INC. *
  6. 60  REM  *  LINCOLN, MA. 01773  *
  7. 70  REM  ************************
  8. 80  TEXT : HOME : PRINT "** COPYRIGHT 1983 BY MICROSPARC, INC. **": PRINT : PRINT 
  9. 90  DIM H(279),L(279)
  10. 100 MM = 1E10:UH =  -MM:UL = MM:VH =  -MM:VL = MM
  11. 110  FOR I = 0 TO 279:L(I) = 191: NEXT 
  12. 120  PRINT "LINE OF SIGHT:": INPUT "XE,YE,ZE=";XE,YE,ZE
  13. 130 S1 = XE *XE +YE *YE:S2 =  SQR(S1):S3 =  SQR(S1 +ZE *ZE):S4 = 1/(S2 *S3)
  14. 140  INPUT "M=";M: INPUT "N=";N
  15. 150  DIM X(M),Y(N),R(M,N,1)
  16. 160  INPUT "XLOW =";XL: INPUT "XHIGH=";XH: INPUT "YLOW =";YL: INPUT "YHIGH=";YH
  17. 170 DX = (XH -XL)/M:DY = (YH -YL)/N
  18. 180 X0 = XH: IF XE <0  THEN DX =  -DX:X0 = XL
  19. 190 Y0 = YH: IF YE <0  THEN DY =  -DY:Y0 = YL
  20. 200 CX = 140:CY = 96
  21. 210  FOR I = 0 TO M:X(I) = X0 -I *DX: NEXT 
  22. 220  FOR J = 0 TO N:Y(J) = Y0 -J *DY: NEXT 
  23. 230  FOR I = 0 TO M: FOR J = 0 TO N
  24. 240 X = X(I):Y = Y(J)
  25. 250  REM  ***
  26. 260  REM  * REPLACEABLE FUNCTION *
  27. 270  REM  ** Z = F(X,Y) FOLLOWS **
  28. 280  REM  ***
  29. 290 Z =  EXP( -X *X -Y *Y)
  30. 300  REM  ***
  31. 310  REM  ***
  32. 320  GOSUB 890
  33. 330 R(I,J,0) = U:R(I,J,1) = V: GOSUB 1420
  34. 340  NEXT J: VTAB 14: PRINT "I=";I,"MAX=";M: NEXT I
  35. 350  REM  S=SCALE FACTOR
  36. 360 S = MM: IF UL = 0  THEN 380
  37. 370 S0 = 139/ ABS(UL): IF S0 <S  THEN S = S0
  38. 380  IF UH = 0  THEN 400
  39. 390 S0 = 139/ ABS(UH): IF S0 <S  THEN S = S0
  40. 400  IF VL = 0  THEN 420
  41. 410 S0 = 95/ ABS(VL): IF S0 <S  THEN S = S0
  42. 420  IF VH = 0  THEN 450
  43. 430 S0 = 95/ ABS(VH): IF S0 <S  THEN S = S0
  44. 440  REM  LOCATE IN HGR2 COORDINATES
  45. 450  FOR I = 0 TO M: FOR J = 0 TO N
  46. 460 R(I,J,0) =  INT(S *R(I,J,0) +CX):R(I,J,1) =  INT(S *R(I,J,1) +CY)
  47. 470  NEXT J: NEXT I
  48. 480  REM  START GRAPHICS
  49. 490  HGR2 : HCOLOR= 3
  50. 500  IF  ABS(XE) < ABS(YE)  THEN 670
  51. 510  FOR I = 0 TO M
  52. 520  REM  DRAW FIXED X LINES
  53. 530  FOR J = 1 TO N
  54. 540 U1 = R(I,J -1,0):V1 = R(I,J -1,1):U2 = R(I,J,0):V2 = R(I,J,1)
  55. 550  GOSUB 950: REM  TEST VISIBILITY AND PLOT
  56. 560  GOSUB 1220: REM  UPDATE H,L ARRAYS
  57. 570  NEXT J
  58. 580  IF I = M  THEN 650
  59. 590  REM  DRAW FIXED Y LINE SEGMENTS
  60. 600  FOR J = 0 TO N
  61. 610 U1 = R(I,J,0):V1 = R(I,J,1):U2 = R(I +1,J,0):V2 = R(I +1,J,1)
  62. 620  GOSUB 950: REM  TEST VISIBILITY AND PLOT
  63. 630  GOSUB 1220: REM  UPDATE H,L ARRAYS
  64. 640  NEXT J
  65. 650  NEXT I
  66. 660  GOTO 820
  67. 670  FOR J = 0 TO N
  68. 680  REM  DRAW FIXED Y LINES
  69. 690  FOR I = 1 TO M
  70. 700 U1 = R(I -1,J,0):V1 = R(I -1,J,1):U2 = R(I,J,0):V2 = R(I,J,1)
  71. 710  GOSUB 950
  72. 720  GOSUB 1220
  73. 730  NEXT I
  74. 740  IF J = N  THEN 810
  75. 750  REM  DRAW FIXED X LINE SEGMENTS
  76. 760  FOR I = 0 TO M
  77. 770 U1 = R(I,J,0):V1 = R(I,J,1):U2 = R(I,J +1,0):V2 = R(I,J +1,1)
  78. 780  GOSUB 950
  79. 790  GOSUB 1220
  80. 800  NEXT I
  81. 810  NEXT J
  82. 820  PRINT  CHR$(7): INPUT "PAPER OUTPUT (Y/N)?";Q$: IF Q$ < >"Y"  THEN  END 
  83. 830  PR# 1
  84. 840  PRINT : POKE  -12524,0: POKE  -12525,64: PRINT  CHR$(17): PR# 0
  85. 850  TEXT : END 
  86. 860  REM  ***
  87. 870  REM  * TRANSFORMATION SUBROUTINE *
  88. 880  REM  ***
  89. 890 U = (XE *Y -YE *X)/S2
  90. 900 V = (ZE *(X *XE +Y *YE) -S1 *Z) *S4
  91. 910  RETURN 
  92. 920  REM  ***
  93. 930  REM  * WRIGHT'S ALGORITHM *
  94. 940  REM  ***
  95. 950 T1 = 0:T2 = 0:G1 = 0:G2 = 0
  96. 960  IF V1 > = H(U1)  THEN T1 = 1
  97. 970  IF V2 > = H(U2)  THEN T2 = 1
  98. 980  IF V1 < = L(U1)  THEN G1 = 1
  99. 990  IF V2 < = L(U2)  THEN G2 = 1
  100. 1000  IF T1 = 1  AND T2 = 1  THEN  HPLOT U1,V1 TO U2,V2: RETURN 
  101. 1010  IF G1 = 1  AND G2 = 1  THEN  HPLOT U1,V1 TO U2,V2: RETURN 
  102. 1020  IF T1 +T2 +G1 +G2 = 0  THEN  RETURN 
  103. 1030  GOSUB 1370
  104. 1040  IF KM = KX  THEN 1160
  105. 1050 F1 = 0:F2 = 0
  106. 1060  FOR K = KM TO KX
  107. 1070 VK = VM +(VX -VM) *(K -KM)/(KX -KM)
  108. 1080  IF VK >H(K)  OR VK <L(K)  THEN U1 = K:V1 = VK:F1 = 1:K = KX
  109. 1090  NEXT 
  110. 1100  FOR K = KX TO KM  STEP  -1
  111. 1110 VK = VM +(VX -VM) *(K -KM)/(KX -KM)
  112. 1120  IF VK >H(K)  OR VK <L(K)  THEN U2 = K:V2 = VK:F2 = 1:K = KM
  113. 1130  NEXT 
  114. 1140  IF F1 = 1  AND F2 = 1  THEN  HPLOT U1,V1 TO U2,V2
  115. 1150  RETURN 
  116. 1160  IF VX >H(U1)  THEN  HPLOT U1,H(U1) TO U1,VX: RETURN 
  117. 1170  IF VM <L(U1)  THEN  HPLOT U1,L(U1) TO U1,VM
  118. 1180  RETURN 
  119. 1190  REM  ***
  120. 1200  REM  * UPDATE H AND L ARRAYS *
  121. 1210  REM  ***
  122. 1220  IF V1 >H(U1)  THEN H(U1) = V1
  123. 1230  IF V2 >H(U2)  THEN H(U2) = V2
  124. 1240  IF V1 <L(U1)  THEN L(U1) = V1
  125. 1250  IF V2 <L(U2)  THEN L(U2) = V2
  126. 1260  IF  ABS(U1 -U2) < = 1  THEN  RETURN 
  127. 1270  GOSUB 1370
  128. 1280  FOR K = KM +1 TO KX -1
  129. 1290 VK = VM +(VX -VM) *(K -KM)/(KX -KM)
  130. 1300  IF VK >H(K)  THEN H(K) = VK
  131. 1310  IF VK <L(K)  THEN L(K) = VK
  132. 1320  NEXT K
  133. 1330  RETURN 
  134. 1340  REM  ***
  135. 1350  REM  * FIND LEFTMOST POINT ON THE LINE *
  136. 1360  REM  ***
  137. 1370 KM = U1:KX = U2:VM = V1:VX = V2: IF KM >KX  THEN KM = U2:KX = U1:VM = V2:VX = V1: RETURN 
  138. 1380  RETURN 
  139. 1390  REM  ***
  140. 1400  REM  * FIND EXTREME VALUES IN U,V COORD. BEFORE SCALING *
  141. 1410  REM  ***
  142. 1420  IF U >UH  THEN UH = U
  143. 1430  IF U <UL  THEN UL = U
  144. 1440  IF V >VH  THEN VH = V
  145. 1450  IF V <VL  THEN VL = V
  146. 1460  RETURN